MacGames Sampler/PHT MacGames Bundle.iso/MacSource Folder/Samples from the CD/Pascal/Source□/Talk Source/My Libraries/MyFileSystem.unit

Text File | 1992-04-20 | 7.6 KB | 333 lines | [TEXT/PJMM]

unit MyFileSystem;

{ This program was written by Peter N Lewis, Mar 1992 in THINK Pascal 4.0.1 }

interface

    const
        PAvailable = fsCurPerm;
        PIn = fsRdPerm;
        POut = fsWrPerm;
        PInOut = fsRdWrPerm;
        PShared = fsRdWrShPerm;
        buf_size = 2048;
        eof_byte = $1A;

    type
        bufferArray = packed array[0..buf_size] of byte;
        bufferPtr = ^bufferArray;
        bufferHandle = ^bufferPtr;
        MFSfile = record
                reading: boolean;
                rn: integer;
                buf_len, buf_pos: longInt;
                eof: boolean;
                length: longInt;
                buf: bufferHandle;
            end;

    function MFSExists (wdrn: integer; dirID: longInt; name: str255): boolean;
    function MFSDirExists (wdrn: integer; dirID: longInt; name: str255): boolean;
    procedure MFSUniqueName (wdrn: integer; dirID: longInt; var name: str63);
    function MFSOpenIn (wdrn: integer; dirID: longInt; name: str255; var thefile: MFSfile): OSErr;
    function MFSCreate (wdrn: integer; dirID: longInt; name: str255; c, t: OSType): OSErr;
{    function MFSDelete (wdrn: integer; dirID: longInt; name: str255): OSErr;}
{ use HDelete instead}
    function MFSOpenOutDF (wdrn: integer; dirID: longInt; name: str255; c, t: OSType; var thefile: MFSfile): OSErr;
    function MFSOpenOutRF (wdrn: integer; dirID: longInt; name: str255; c, t: OSType; var thefile: MFSfile): OSErr;
    function MFSEof (var thefile: MFSfile): boolean;
    function MFSLength (var thefile: MFSfile): longInt;
    function MFSReadByte (var thefile: MFSfile; var b: byte): OSErr;
    function MFSWriteByte (var thefile: MFSfile; b: byte): OSErr;
    function MFSClose (var thefile: MFSfile): OSErr;
    function MFSOpenDF (var rn: integer; wdrn: integer; dirID: longInt; name: str63; perm: integer): OSErr;
    function MFSOpenRF (var rn: integer; wdrn: integer; dirID: longInt; name: str63; perm: integer): OSErr;
{ perm = fsCurPerm, fsRdPerm, fsWrPerm, fsRdWrPerm, fsRdWrShPerm }
    procedure SegmentMFSByte;
    procedure SegmentMFS;

implementation

    uses
        MyTypes;

{$S MFSByte}
    procedure SegmentMFSByte;
    begin
    end;

{$S MFS}
    procedure SegmentMFS;
    begin
    end;

{$S MFSByte}
    procedure InitTheFile (var thefile: MFSfile);
    begin
        thefile.buf := bufferHandle(NewHandle(buf_size));
    end;

{$S MFS}
    function MFSExists (wdrn: integer; dirID: longInt; name: str255): boolean;
        var
            pb: HParamBlockRec;
    begin
        with pb do begin
            ioNamePtr := @name;
            ioVRefNum := wdrn;
            ioDirID := dirID;
            ioFDirIndex := 0;
        end;
        MFSExists := PBHGetFInfo(@pb, false) = noErr;
    end;

{$S MFS}
    function MFSDirExists (wdrn: integer; dirID: longInt; name: str255): boolean;
        var
            pb: HParamBlockRec;
            oe: OSErr;
    begin
        with pb do begin
            ioNamePtr := @name;
            ioVRefNum := wdrn;
            ioDirID := dirID;
            if name = '' then
                ioFDirIndex := -1
            else
                ioFDirIndex := 0;
        end;
        oe := PBGetCatInfo(@pb, false);
        MFSDirExists := (oe = noErr) and (BAND(pb.ioFlAttrib, $0010) <> 0);
    end;

{$S MFS}
    procedure MFSUniqueName (wdrn: integer; dirID: longInt; var name: str63);
        var
            base: str31;
            n: integer;
    begin
        if MFSExists(wdrn, dirID, name) then begin
            base := Concat(Copy(name, 1, 27), '#');
            n := 1;
            repeat
                name := Concat(base, chr(n div 100 + 48), chr(n div 10 mod 10 + 48), chr(n mod 10 + 48));
                n := n + 1;
            until not MFSExists(wdrn, dirID, name);
        end;
    end;

{$S MFSByte}
    function MFSOpenIn (wdrn: integer; dirID: longInt; name: str255; var thefile: MFSfile): OSErr;
    begin
        InitTheFile(thefile);
        with thefile do begin
            reading := true;
            buf_pos := 0;
            buf_len := 0;
            MFSOpenIn := MFSOpenDF(rn, wdrn, dirID, name, PIn);
            if GetEOF(rn, length) <> noErr then
                length := 0;
            eof := length = 0;
        end;
    end;

{$S MFS}
    function MFSCreate (wdrn: integer; dirID: longInt; name: str255; c, t: OSType): OSErr;
        var
            ooe, oe: integer;
            fi: Finfo;
    begin
        oe := HCreate(wdrn, dirID, name, c, t);
        if oe = dupFNErr then begin
            ooe := HGetFInfo(wdrn, dirID, name, fi);
            oe := HDelete(wdrn, dirID, name);
            oe := HCreate(wdrn, dirID, name, c, t);
            if (oe = noErr) and (ooe = noErr) then begin
                fi.fdType := t;
                fi.fdCreator := c;
                ooe := HSetFInfo(wdrn, dirID, name, fi);
            end;
        end;
        MFSCreate := oe;
    end;

{$S MFSByte}
    function MFSOpenOutDF (wdrn: integer; dirID: longInt; name: str255; c, t: OSType; var thefile: MFSfile): OSErr;
        var
            oe: integer;
            fi: fInfo;
    begin
        InitTheFile(thefile);
        with thefile do begin
            reading := false;
            oe := MFSCreate(wdrn, dirID, name, c, t);
            if oe = noErr then
                oe := MFSOpenDF(rn, wdrn, dirID, name, POut);
            buf_pos := 0;
            buf_len := 0;
            length := 0;
            eof := false;
            MFSOpenOutDF := oe;
        end;
    end;

{$S MFSByte}
    function MFSOpenOutRF (wdrn: integer; dirID: longInt; name: str255; c, t: OSType; var thefile: MFSfile): OSErr;
        var
            oe: integer;
    begin
        InitTheFile(thefile);
        with thefile do begin
            reading := false;
            oe := MFSCreate(wdrn, dirID, name, c, t);
            if oe = dupFNErr then
                oe := noErr;
            if oe = noErr then
                oe := MFSOpenRF(rn, wdrn, dirID, name, POut);
            buf_pos := 0;
            buf_len := 0;
            length := 0;
            eof := false;
            MFSOpenOutRF := oe;
        end;
    end;

{$S MFSByte}
    function MFSLength (var thefile: MFSfile): longInt;
        var
            l: longInt;
    begin
        MFSLength := thefile.length;
    end;

{$S MFSByte}
    function MFSEof (var thefile: MFSfile): boolean;
    begin
        MFSEof := thefile.eof;
    end;

{$S MFSByte}
    function MFSReadByte (var thefile: MFSfile; var b: byte): OSErr;
        var
            oe: OSErr;
        procedure Read;
        begin
            with thefile do begin
                buf_pos := 0;
                buf_len := buf_size;
                oe := FSRead(rn, buf_len, POINTER(buf^));
                if oe = eofErr then
                    oe := noErr;
                if buf_len = 0 then
                    oe := eofErr;
                if oe <> noErr then begin
                    buf_len := 0;
                    eof := true;
                end;
            end;
        end;
    begin
        with thefile do
            if reading then begin
                if eof then begin
                    b := eof_byte;
                    MFSReadByte := eofErr;
                end
                else begin
                    oe := noErr;
                    if buf_pos = buf_len then
                        Read;
                    MFSReadByte := oe;
                    if oe = noErr then begin
                        b := buf^^[buf_pos];
                        buf_pos := buf_pos + 1;
                        if buf_pos = buf_len then
                            Read;
                    end;
                end;
            end
            else
                MFSReadByte := paramErr;
    end;

{$S MFSByte}
    function Flush (var thefile: MFSfile): OSErr;
        var
            count: longInt;
            oe: integer;
    begin
        with thefile do begin
            count := buf_pos;
            if count = 0 then
                oe := noErr
            else
                oe := FSWrite(rn, count, POINTER(buf^));
            if count <> buf_pos then
                oe := ioErr;
            buf_len := 0;
            buf_pos := 0;
        end;
        Flush := oe;
    end;

{$S MFSByte}
    function MFSWriteByte (var thefile: MFSfile; b: byte): OSErr;
    begin
        with thefile do
            if not reading then begin
                buf^^[buf_pos] := b;
                buf_pos := buf_pos + 1;
                if buf_pos = buf_size then
                    MFSWriteByte := Flush(thefile)
                else
                    MFSWriteByte := noErr;
            end
            else
                MFSWriteByte := paramErr;
    end;

{$S MFSByte}
    function MFSClose (var thefile: MFSfile): OSErr;
        var
            oe: integer;
    begin
        if not thefile.reading then
            oe := Flush(thefile);
        MFSClose := FSClose(thefile.rn);
        thefile.rn := 0;                { Never close a file twice }
        DisposHandle(handle(thefile.buf));
    end;

{$S MFS}
    function MFSOpenDF (var rn: integer; wdrn: integer; dirID: longInt; name: str63; perm: integer): OSErr;
        var
            pb: HParamBlockRec;
    begin
        with pb do begin
            ioNamePtr := @name;
            ioVRefNum := wdrn;
            ioPermssn := perm;
            ioMisc := nil;
            ioDirID := dirID;
            MFSOpenDF := PBHOpen(@pb, false);
            rn := ioRefNum;
        end;
    end;

{$S MFS}
    function MFSOpenRF (var rn: integer; wdrn: integer; dirID: longInt; name: str63; perm: integer): OSErr;
        var
            pb: HParamBlockRec;
    begin
        with pb do begin
            ioNamePtr := @name;
            ioVRefNum := wdrn;
            ioPermssn := perm;
            ioMisc := nil;
            ioDirID := dirID;
            MFSOpenRF := PBHOpenRF(@pb, false);
            rn := ioRefNum;
        end;
    end;

end.